MacFormat 1994 November/macformat-018.iso/Utility Spectacular/Developer/macgambit-20-compiler-src-p1/Examples/quickdraw-demo.scm

Text File | 1994-07-26 | 5.1 KB | 138 lines | [TEXT/gamI]

; Quickdraw demo

; (represent obj) pops up a window with the graphical representation of 'obj'.
; To get control back, press the mouse button.
;
; Note that, contrary to the Pascal and C version of the Quickdraw procedures,
; the Scheme procedures take an extra argument: the port to apply the
; operation on.  The port is always the first argument.

(define (represent obj)

  (define v-offs  0) ; vertical offset of grid
  (define h-offs 20) ; horizontal

  (define grid-v 24) ; vertical spacing between grid lines
  (define grid-h 48) ; horizontal

  (define cons-v 12) ; vertical size of cons cell
  (define cons-h 24) ; horizontal

  (define arrow-head-length 6) ; size of arrows
  (define arrow-head-width  6)
  (define arrow-space       2)

  (define fontsize 12)

  (let ((w (mac#newwindow
             (mac#rect 40 10 250 500)
             "Box Representation"
             #t    ; visible
             4     ; nogrowdoc
             -1    ; in front of all windows
             #t))) ; goawaybox

    (define (draw-cons-cell x y)
      (let ((v (+ (* y grid-v) v-offs))
            (h (+ (* x grid-h) h-offs)))
        (mac#framerect w (mac#rect v h (+ v cons-v) (+ h cons-h)))
        (mac#moveto w (+ h (quotient cons-h 2)) v)
        (mac#line w 0 (- cons-v 1))))

    (define (draw-car-arrow x y d) ; draw arrow downwards 'd' grid squares
      (let ((v (+ (* y grid-v) v-offs))
            (h (+ (* x grid-h) h-offs)))
        (mac#moveto w (+ h (quotient cons-h 4)) (+ v (quotient cons-v 2)))
        (mac#line w 0 (- (* d grid-v) (+ (quotient cons-v 2) arrow-space)))
        (mac#line w (quotient arrow-head-width 2) (- arrow-head-length))
        (mac#move w (- arrow-head-width) 0)
        (mac#line w (quotient arrow-head-width 2) arrow-head-length)))

    (define (draw-cdr-arrow x y d) ; draw arrow to the right 'd' grid squares
      (let ((v (+ (* y grid-v) v-offs))
            (h (+ (* x grid-h) h-offs)))
        (mac#moveto w (+ h (quotient (* cons-h 3) 4)) (+ v (quotient cons-v 2)))
        (mac#line w (- (* d grid-h) (+ (quotient (* cons-h 3) 4) arrow-space)) 0)
        (mac#line w (- arrow-head-length) (quotient arrow-head-width 2))
        (mac#move w 0 (- arrow-head-width))
        (mac#line w arrow-head-length (quotient arrow-head-width 2))))

    (define (draw-nil x y) ; draw nil in cdr of cons cell
      (let ((v (+ (* y grid-v) v-offs))
            (h (+ (* x grid-h) h-offs)))
        (mac#moveto w (+ h (quotient cons-h 2)) (+ v (- cons-v 1)))
        (mac#line w (- (quotient cons-h 2) 1) (- (- cons-v 1)))))

    (define (object->string obj)
      (let ((port (open-output-string)))
        (write obj port)
        (let ((str (get-output-string port)))
          (close-output-port port)
          str)))

    (define (object-length obj) ; length of object in grid squares
      (cond ((null? obj)
             0)
            ((pair? obj)
             (+ 1 (object-length (cdr obj))))
            (else
             (+ 1 (quotient (+ (mac#stringwidth w (object->string obj)) fontsize)
                            grid-h)))))

    (define (initial-profile) 0)
    (define (car-profile p) (if (pair? p) (car p) p))
    (define (cdr-profile p) (if (pair? p) (cdr p) p))

    (define (make-profile len p)
      (define (fit1 len p)
        (if (> len 1)
          (let ((p* (fit1 (- len 1) (cdr-profile p))))
            (cons (car-profile p*) p*))
          (fit2 (+ (car-profile p) 1) p)))
      (define (fit2 y p)
        (if (pair? p)
          (cons (max y (car-profile p)) (fit2 y (cdr-profile p)))
          (max y p)))
      (fit1 len p))

    (define (draw-list lst x y p)
      (draw-cons-cell x y)
      (let* ((tail (cdr lst))
             (tail-p (cdr-profile p))
             (new-p (cond ((null? tail)
                           (draw-nil x y)
                           tail-p)
                          ((pair? tail)
                           (draw-cdr-arrow x y 1)
                           (draw-list tail (+ x 1) y tail-p))
                          (else
                           (draw-cdr-arrow x y 1)
                           (mac#move w arrow-space (quotient fontsize 2))
                           (mac#drawstring w (object->string tail))
                           tail-p))))
        (draw-object (car lst) x y (cons (car-profile p) new-p))))

    (define (draw-object obj x y p)
      (if (pair? obj)
        (let ((len (object-length obj)))
          (let ((new-p (make-profile len p)))
            (let ((yy (car-profile new-p)))
              (draw-car-arrow x y (- yy y))
              (draw-list obj x yy new-p))))
        (let ((text (object->string obj)))
          (draw-car-arrow x y 1)
          (mac#move w (- (quotient (mac#stringwidth w text) 2)) fontsize)
          (mac#drawstring w text)
          (make-profile 1 p))))

    (if (not (= w 0)) ; make sure it was created...
      (begin
        (mac#textfont w 3) ; geneva
        (mac#textface w 1) ; bold
        (mac#textsize w fontsize)
        (draw-object obj 0 0 (initial-profile))
        (let loop () (if (not (mac#button)) (loop)))
        (mac#disposewindow w)))))

(represent '(define (fact n) (if (< n 2) 1 (* (fact (- n 1)) n))))